perm filename R11A.F4[P11,LCS] blob
sn#341670 filedate 1978-03-12 generic text, type T, neo UTF8
C RUNIT 2ND HALF OF SCORE.
C************************************ DOUBLE PRECISION IFM,IFM2,SCAL,VX
COMMON /Q/ BNW(100),NWZ /INS/INST(27),BG(60) /TYP/SOS,JOUT
1 ,LN,ITYP,TPALN,JED
COMMON/VV/LIMIT, V(2000) /A/ ROFF(27),NP(27),PCH(27,32),
1 RDEV(27),IPT(27,31),XT(27),OTH(20,16),SCAL(101)
1 ,P1(27),JFM(4),COPY(30),IFM(80)
1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
DIMENSION IV(1),IT(30),IOUT(70),JPT(837),NCNT(27,32)
1,COFF1(27),COFF2(27),RREST(27),AA(100)
C WITH VX,IOUT AT 70 AND IFM AT 80 OK FOR ONLY
C 40 LIT CHARS + 30 PARAMS PER INST.
C 60 BG TIMES AVAILABLE. FOR INSTS AND INSERTS AND EDITS.
COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
1 ZZ,CHN,YY
1 /D/TF,AMPFAC,OP1,DURX,IXIN,IFLNM
1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
1 KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2,T1,RD,
1 VIJ2
C /C/=26
EQUIVALENCE (PP1,P(1)),(P(2),P2),(P(3),P3),(P(4),P4),
1 (VX1,VX(1)),(INP1,INP(1)),(PL4,PL(4)),(IPT,JPT)
1 ,(VX2,VX(2)),(VX3,VX(3)),(NCNT,PCH),(VX4,VX(4))
1 ,(VX5,VX(5)),(VX,IOUT),(IFM3,IFM(3)),(AA,NA)
1 ,(IT,INP(28)),(V,IV),(IFM2,IFM(2))
1 ,(IFM4,IFM(4)),(COFF1,INP(58)),(COFF2,INP(85))
1 ,(RREST,INP(112))
C****** SCAL MUST BE DBL PREC.
DATA SCAL/'C/8','CS/8','D/8','DS/8','E/8','F/8','FS/8','G/8',
1 'GS/8','A/8','AS/8','B/8','C/4','CS/4','D/4','DS/4','E/4',
1 'F/4','FS/4','G/4','GS/4','A/4','AS/4','B/4','C/2','CS/2',
1 'D/2','DS/2','E/2','F/2','FS/2','G/2','GS/2','A/2','AS/2',
1 'B/2','C','CS','D','DS','E','F','FS','G','GS','A','AS',
1 'B','C*2','CS*2','D*2','DS*2','E*2','F*2','FS*2','G*2',
1 'GS*2','A*2','AS*2','B*2','C*4','CS*4','D*4','DS*4','E*4',
1 'F*4','FS*4','G*4','GS*4','A*4','AS*4','B*4','C*8','CS*8',
1 'D*8','DS*8','E*8','F*8','FS*8','G*8','GS*8','A*8','AS*8',
1 'B*8','R','F1','F2','F3','F4','F5','F6','F7','F8','F9',
1 'F10','F11','F12','F13','F14','F15','END'/,I1X/'1X'/,
1IFM(1)/'('/,IFM2/'1XA5,'/,IFCOM/5H', ',/,IA1/'A1,'/,RNDOFF/100.0/
1,IBLA/' '/
C**** IFM - 'OBJECT TIME FORMAT ARRAY' MUST BE ALL DBL PREC.
C***** SEE PG6-18 IN PDP11 FORTRAN MANUAL.
CALL RDDAT
ITOT=1
PR=0
DO 9337 K=1,27
COFF1(K)=0
9337 RREST(K)=0
C ZEROS NAME CHANGE, CUTOFF AND RAND REST STORAGE
2337 T=0
DO 1107 K=1,30
1107 PL(K)=1.
C 2/74--WAS AT 17300/1 SETS DEFAULT OUTPUT MODE TO 1.
IF(SOS)WRITE(JOUT,902)
C WRITES A BLANK LINE
NWZZ=0
IAMP=0
IT3=0
K=1
IX=0
BG(NINS+1)=19999.
4011 IF(CNT(K))GO TO 5011
6011 IF(K.EQ.KZY)GO TO 4337
K=K+1
GO TO 4011
5011 L=V(I-1)/(-9900.)
IF(L.EQ.1)I=I-1
V(I)=CNT(K)
V(I+1)=P(K)
V(I+3)=-44.
I=I+5
IF(P(K).EQ.-9797.0)I=I-4
KL=I
CC REWIND 23
ICT=IPT(K,1)
CALL IFILE(23,ICT)
CC CALL IFILE(1,ICT,IFI)
9011 L=I+6
READ(23,7011)(V(M),M=I,L)
C READS "CONDUCT" AND "RHYTHM" (TAP) DATA.
IF(V(L).EQ.999.)GO TO 8011
I=L+1
GO TO 9011
8011 IF(P(K).NE.-9797.0)GO TO 6337
DO 7337 K=L,I,-1
7337 IF(V(K).NE.999.)GO TO 8337
8337 I=K+1
V(I)=999.0
V(I+1)=V(K)
V(I+2)=V(K)
C K WAS I-1 ABOVE.
I=I+3
V(KL+1)=I-KL-1
C ABOVE RESETS WORDCOUNT FOR 'CONDUCT' DATA.
GO TO 4337
6337 DO 5337 M=I,L
KN=M
5337 IF(V(M).EQ.999.)GO TO 3337
3337 I=KN
KN=I-KL
V(KL-1)=KN
V(KL-3)=KN+3
GO TO 6011
7011 FORMAT(7F)
4337 IF(V(I-1).EQ.-9900.-BY)I=I-1
V(I)=-19899.
PP1=0
T6=10000.
DO 2118 K=1,NINS
ROFF(K)=0
M=NP(K)
IT(K)=0
IPT(K,31)=0
NCNT(K,31)=1
DO 2118 L=1,M
NCNT(K,L)=1
2118 IPT(K,L)=0
DO 5013 K=1,IXIN
5013 X=RAND(0.0,0.0)
C***** SEE PDP11 FORTRAN MANUAL RE. RAN - PG. B-16
C NOW USES EXTENSION .DAT WHEN WRITING ON DSK (DEV. 1 ONLY!)
NW=1
NWX=0
TDUR=0
A=0
T2=1.
T4=1.
T5=0
J=1
MK=0
C IS THE ABOVE NEEDED?
IF(MX.NE.3)GO TO 40021
K=4
10023 N=AMOD(V(K),100.0)/-11.
C AMOD NEEDED BECAUSE CODE # MAY HAVE -100 FOR DF OR -200 FOR SUBR.
IF(N.EQ.2)GO TO 77
IF(N.EQ.3)GO TO 77
IF(N.NE.4)GO TO 10021
77 IF(V(K-2).LT.10000.)GO TO 10021
J=V(K+1)
IF(J.EQ.1)GO TO 10024
IF(N.NE.3)GO TO 177
IF(V(K+J+1).EQ.101.)J=J-1
177 N=V(K-2)
L=N/10000
M=N-L*10000
TYPE 10022,INST(L),M,J
10024 K=K+ABS(V(K-1))
10021 K=K+1
IF(K.LT.I)GO TO 10023
40021 IF(MZ.NE.-4)GO TO 1002
N=1
40022 K=N+1
IF(N.GT.I)CALL EXIT
X=V(N)
IF(X.EQ.-199.)GO TO 40024
IF(X.EQ.-99.)GO TO 40024
IF(X.GE.0)GO TO 40023
CC PRINT 4002,X
TYPE 4002,X
N=N+1
GO TO 40022
40024 J=N+1
GO TO 40025
C FOR 'SECTIONS'
40023 J=ABS(V(K))+K-1
40025 TYPE 4002,(V(K),K=N,J)
N=J+1
GO TO 40022
10022 FORMAT(1XA5,' P',I2,' HAS ',I3,' ITEMS.')
4002 FORMAT(10F12.3)
1002 IF(IDALL)GO TO 600
X=DUR(IDALL)
DO 2002 K=1,NINS
2002 IF(DUR(K))DUR(K)=X
C ***** SORTER *************************
C ******* OUTPUT LOOP FROM HERE ON ********
600 IL=0
C********** BELOW IS FOR 'SECTIONS'
KODE=0
NWX=NWX+1
MK=MK+1
Y=BNW(NW)
723 IL=IL+1
3723 Z=V(IL)
IF(Z.EQ.-19899.)GO TO 732
IF(Z.NE.-9900.-Y)GO TO 723
C********** BELOW IS FOR 'SECTIONS'
IF(V(IL-2).EQ.-199.)KODE=IV(IL-1)
2723 IL=IL+1
729 K=IL+2
MOT=V(IL+1)
RD=V(K)
IF(RD.EQ.-67.)GO TO 3726
RB=V(IL)
C************ DOWN TO 4150 IS FOR 'SECTIONS'
IF(RB.NE.-99.)GO TO 4150
KODE=IV(K-1)
2160 IF(KODE.EQ.0)GO TO 723
IF(MZ)WRITE(JOUT,9150),KODE
KL=Y/10000.
RB=Y+KL*10000.
DO 5150 KL=1,I
IF(V(KL).NE.-199.)GO TO 5150
IF(IV(KL+1).NE.KODE)GO TO 5150
IV(K-1)=0
C WHEN 'PLAY' HAS BEEN FOUND, INDENTIFIER CHNGED TO 0
RD=V(KL+2)+9900.
DO 6150 L=KL+2,I
M=V(L)/(-9900.)
IF(M.NE.1)GO TO 6150
RA=RB+RD-V(L)-9900.
V(L)=-9900.-RA
C UPDATES BG TIMES INSIDE SECTION.
CALL BGSORT(RA)
C UPDATES LIST OF CHANGE TIMES.
6150 IF(V(L).EQ.-299.)GO TO 160
5150 CONTINUE
160 IL=1
GO TO 3723
C*********** ABOVE IS FOR 'SECTION' REPEATS
4150 LK=RB/10000.+.2
IF(LK.GE.98)GO TO 7700
LP=RB-LK*10000
C LK=INST # LP=PARAM #
LN=IPT(LK,LP)
IPT(LK,LP)=IL+2
IF(RD.EQ.-66.)GO TO 726
IF(RD.EQ.-55.)GO TO 1726
IF(RD.EQ.-56.)GO TO 1726
IF(RD.EQ.-23)GO TO 6700
2727 ML=IPT(LK,LP)
IF(MOT.GT.0)GO TO 3727
C USE NEG WDCNT FOR 'ALL'
DO 4727 KL=LK+1,NINS
IF(NP(KL).GE.LP)GO TO 277
IF(LP.LT.31)NP(KL)=LP
277 IPT(KL,LP)=-(LK+(LP-1)*KZY)
NCNT(KL,LP)=10000
4727 IF(DUR(KL))DUR(KL)=10000.
C ASSUMES THAT DURATIONS ARE SET IN 'NOTES'.
C AFTER 'ALL' IS USED ONCE IT WORKS LIKE DUPL OR REP.
GO TO 727
C 'MOVE' WITH 'ALL' KEEPS ORIGINAL TIME DATA REGARDLESS OF BG TIMES.
3727 IF(LN.LE.0)GO TO 727
IF(V(IL).NE.V(LN-1))GO TO 727
DO 1727 L=1,NINS
DO 1727 KL=1,NP(L)
IF(LN.NE.IPT(L,KL))GO TO 1727
NCNT(L,KL)=10000
C ******* JAN 29,70
IPT(L,KL)=ML
C RESETS POINTERS FOR DUPL AND REP INSTS.
C *** 'ALL' WILL NOT WORK WITH RAN TF.!!!!!*******FEB 21,73
1727 CONTINUE
727 NCNT(LK,LP)=10000
C******** MAY 13,71 RHY REP. FEATURE OMITTED.
2150 IF(MOT)MOT=-MOT
IL=IL+MOT+1
3150 IF(V(IL))GO TO 3723
GO TO 729
726 RB=V(IL+3)
K=RB/10000.
L=RB-K*10000
IPT(LK,LP)=-(K+(L-1)*KZY)
GO TO 2727
3726 LK=V(IL)
M=V(K+1)
KL=NP(M)
DO 4726 L=1,KL
IPT(LK,L)=IPT(M,L)
IF(IPT(M,L).NE.0)NCNT(LK,L)=10000
4726 CONTINUE
IPT(LK,31)=IPT(M,31)
K=0
GO TO 2150
C ABOVE IS FOR DUPLICATION ROUTINE NEXT ADJUSTS TIMES FOR 'RTAP'
6700 KL=IL+V(IL+1)+1.3
RC=V(K-2)
1770 IF(V(KL))GO TO 700
2700 KL=KL+V(KL+1)+1.3
GO TO 1770
700 KL=KL+1
IF(Z.NE.V(KL-1))GO TO 2700
IF(V(KL).NE.RC)GO TO 2700
KL=KL+3
KN=IL+3
LN=V(KN)+.3
DO 3700 L=1,LN,2
RA=V(L+KN)
KA=V(L+KN+1)+.3
RB=0
DO 4700 LP=1,KA
4700 RB=RB+V(KL+LP)
DO 5700 LP=1,KA
5700 V(KL+LP)=V(KL+LP)/RB*RA
V(KL+KA)=V(KL+KA)+.00030
3700 KL=KL+KA
GO TO 2150
C BELOW FOR 'TEMPO' SETUP
7700 T2=V(IL+4)
T1=V(IL+3)
TBG=Y
TDUR=V(IL+2)
CALL SQYY(AC,T1,T2,TDUR)
8700 IF(TDUR.EQ.0)TDUR=10000.
T5=1.
T6=TBG+TDUR
IT3=1.
IF(LK.EQ.98)IT3=IL+2
T4=1.
GO TO 2150
C*************** ANY WDCNTS DOWN FROM HERE. *********
C NEXT ADJUSTS 'MOVE' TIMES IF BG IS AT A NOTE NUMBER.
1726 IF(V(IL-1).GT.-19000.)GO TO 2727
RA=BT
K=IL-1
2726 V(K)=-9900.-RA
ISUB=-1
L=K+5
RB=V(L)+V(L-1)
V(L-1)=RA
K=K+V(K+2)+2
IF(V(K).GT.-19000.)GO TO 2727
IF(V(K+1).NE.V(IL))GO TO 2727
IF(V(K).NE.-9900.-RB)GO TO 2727
RA=RA+V(L)
CALL BGSORT(RA)
GO TO 2726
C CONVERTS BG TIME OF NOTE NUM TO REAL TIME. DOESN'T WORK WITH -66!
C NOW WE BEGIN ON!! NOTE NUM. NOT AFTER NOTE NUM.
732 DO 2606 K=NW,NWZ
2606 BNW(K)=BNW(K+1)
NWZ=NWZ-1
IF(NWZ.EQ.0)GO TO 2111
IF(NWZZ.EQ.1)GO TO 5111
NWZZ=1
IF(NWZ.EQ.1)GO TO 1111
DO 3111 K=1,NWZ
IF(BNW(K).LT.1000.)GO TO 3111
X=BNW(NWZZ)
BNW(NWZZ)=BNW(K)
BNW(K)=X
NWZZ=NWZZ+1
3111 CONTINUE
5111 IF(NWZZ.EQ.NWZ)GO TO 1111
L=NWZZ+1
X=BNW(NWZZ)
DO 4111 K=L,NWZ
IF(BNW(K).GT.X)GO TO 4111
RA=BNW(K)
BNW(K)=X
X=RA
4111 CONTINUE
BNW(NWZZ)=X
GO TO 1111
111 FORMAT(1XA5,'.DAT',12X,'EDIT FILE NAME=',A5,8X,
1'STORAGE=',I5,'/',I5,/' TEMPO FACTOR=',F6.2/)
1023 FORMAT(/' < ',A5,'.DAT -- RANDOM NUMBER=',I6/' PLAY;')
C********** BELOW IS FOR 'SECTIONS'
9150 FORMAT(/3X'******* SECTION ',A1)
2111 NWZ=-1
C ABOVE ORDERS BNW DATA TO SAVE TIME AT 1108 ON PG5.
1111 IF(MZ.EQ.0)GO TO 1601
IF(NWX.NE.1)GO TO 1486
WRITE(JOUT,111)ISLAC,IFLNM,I,LIMIT,TF
C********** BELOW IS FOR 'SECTIONS'
1486 IF(KODE.NE.0)WRITE(JOUT,9150),KODE
K=NWX-1
IF(NWX.LE.1)GO TO 377
IF(IT(J).NE.-3)WRITE(JOUT,3154),K,Y
377 IF(IT(J).EQ.-3)WRITE(JOUT,5154),K,BX,INST(J)
DO 602 K=1,NINS
48 LK=INST(K)
IF(NCNT(K,31).EQ.10000)GO TO 477
IF(NWX.GT.1)GO TO 602
477 NCNT(K,31)=1
IJ=IPT(K,31)
X=0
IF(IJ.NE.0)X=V(IJ+2)
WRITE(JOUT,5396),LK,X
X=DUR(K)
IF(X.GT.10000.)GO TO 83
WRITE(JOUT,8396),X
GO TO 602
5396 FORMAT(5XA5,' RANDOM TF =',F4.2,10X,'DURATION =',$)
7396 FORMAT('+',F5.0,' NOTES')
8396 FORMAT('+',F7.2,'"')
83 X=X-10000.
WRITE(JOUT,7396),X
602 CONTINUE
715 IF(IT3.NE.1.)GO TO 1602
RA=T1*TP
RB=T2*TP
WRITE(JOUT,6154),RA,RB,TDUR
IT3=0
1602 IF(NWX.EQ.1)GO TO 315
IF(IT(J).EQ.-3)GO TO 1108
IT(J)=IT(J)/10
GO TO 1108
6154 FORMAT(' TMP=',F7.3,' TO',F8.3,' DURING',F6.2,' SECS.'/)
7154 FORMAT(' ''CONDUCT'' FILE NAME = ',A5/)
5154 FORMAT(/' << CHANGE',I3,' BEGINS ON NOTE',F5.0,1XA5,' >>'/)
902 FORMAT(1XA5/)
3154 FORMAT(/' << BASIC TIME OF CHANGE',I3,' IS',F8.3,'" >>'/)
4154 FORMAT(' THE FIRST',F9.4,'" ARE OMITTED'/)
C*********** JUNE 1,71
C RCD IS SET IN DATA (←-1;)
315 IF(IT3.GT.1)WRITE(JOUT,7154),ICT
IF(OP1.NE.0)WRITE(JOUT,4154),OP1
1601 IF(NWX.GT.1) GO TO 1108
IF(TF.GT.10.)TF=TF/60.
TF=RNDOFF/TF
C RNDOFF IS ROUND OFF NUMBER. (100 OR 1000)
CROFF 100 HERE FOR NEW DAC!?#@&βX 1/76 TF=1000./TF
DO 6015 K=1,30
6015 COPY(K)=-9900.
C INITS PARAM REPRESSION FEATURE.
IF(KB.EQ.0)GO TO 9926
ML=NINS+1
NL=NINS+KB
DO 9826 LK=ML,NL
K=LK
BW=OTH(K-NINS,1)
9826 BG(K)=BW
C 'OTH' INSERTS, WITH BG TIME IN SECONDS, CAN ONLY BE SET WITH TF=1
9926 DO 5015 K=1,NINS
IQ(K)=BG(K)*10000.
C**** SHOULD IQ BE DBL PREC.???***********
BG(K)=0
INP(K)=0
P1(K)=0
IF(DUR(K).LE.10000.)DUR(K)=DUR(K)-.0001
C******* FEB. 16,71 FOR ROUND-OFF NONSENSE
5015 CNT(K)=0
IF(MZ)WRITE(JOUT,1023),ISLAC,IXIN
IF(MX)WRITE(1,1023)ISLAC,IXIN
BW=0
GO TO 500
752 FORMAT(1X15A5)
C****** ABOVE IS FOR 'OTH' TAKE ALL OTH OUT?? *********
1108 M=0
JC=0
CCHD=0
C NWZZ IS SET AT 3111 IN SORTR. CCHD IS FOR CHORD FEATURE.
IF(NWZ)GO TO 1740
DO 740 K=1,NWZZ
X=BNW(K)
IF(X-.0001.GT.BT)GO TO 2740
IF(X.LE.BW)GO TO 2740
IF(BW)GO TO 2740
IT(J)=IT(J)*10
NW=K
GO TO 600
2740 IF(X.LT.1000.)GO TO 740
IF(X-J*10000.NE.CNT(J)+1.)GO TO 740
X=BT+PR
NW=K
BX=CNT(J)+1.
IT(J)=-3
GO TO 600
740 CONTINUE
IT(J)=0
1740 IF(J.LE.NINS)GO TO 31
7021 K=J-NINS
IF(JC.GT.0)K=JC
5740 IF(PP1.LT.OP1)GO TO 1752
5741 IF(MZ)WRITE(JOUT,752),(OTH(K,L),L=2,16)
IF(MX)WRITE(1,752)(OTH(K,L),L=2,16)
CC IF(MX)WRITE(23,752)(OTH(K,L),L=2,16)
C IF TF .NE.1, ALL INSERT TIMES MUST BE RESET
C IF FIRST PART OF NOTE LIST IS 'OMITTED', CHECK YOUR 'INSERTS'.
DO 8521 L=3,30
8521 COPY(L)=-9900.
C SO THAT ALL PARAMS WILL PRINT,AFTER AN INSERT.
1752 BG(K+NINS)=19999.
OTH(K,1)=19999.
CIRC IF(BW.EQ.-99)GO TO 9726
IF(JC.GT.0)GO TO 21
31 KL=1
IF(KB.EQ.0)GO TO 2031
DO 1031 L=1,KB
K=L
X=OTH(K,1)-1000000.
M=X/100000.
IF(M.NE.J)GO TO 1031
IF(IQ(J).NE.0)GO TO 1031
C M=INST
IF(X-M*100000.EQ.CNT(J)+1)GO TO 5740
1031 CONTINUE
IF(J.GT.NINS)GO TO 500
2031 CNT(J)=CNT(J)+1
ICT=CNT(J)
C INSERT TRAP HERE FOR OVERLAP OF RESTARTED INSTS.******
NPA=NP(J)
PP1=P1(J)
IF(BT.GE.DUR(J))GO TO 5174
IF(IQ(J).EQ.0)GO TO 200
P2=-IQ(J)/10000.
IQ(J)=0
CNT(J)=-1
ICT=-1
C PRINTS REST AND CNT=-1 WHEN 1ST BG TIME IS >0
GO TO 4203
C MK IS FLAG FOR RESTS
200 MK=0
IF(BT.NE.0)GO TO 577
IF(J.EQ.1)GO TO 203
577 IF(IPT(J,1).EQ.0)GO TO 203
KN=IPT(J,1)-1
IF(KN.GT.0)GO TO 12033
12032 KN=JPT(-KN)
IF(KN)GO TO 12032
KN=KN-1
C FOR 'ALL' IN P32. FOLLOWS UP ON POINTERS TO POINTERS!
C SOMEDAY PUT P1(32) IN WITH OTHER PARAMS BELOW!!!!
12033 IJ=V(KN)
IF(ABS(V(KN)).EQ.4.)GO TO 1203
C 'IABS' IS FOR -4 USED WITH 'ALL'
Z=(BT+9900.+V(KN-2))/V(KN+2)
IF(Z.GT.1.)Z=1.
Y=V(KN+3)
X=(V(KN+4)-Y)*Z+Y
GO TO 204
1203 X=V(KN+3)
204 Y=RAND(0.0,1.0)
IF(Y-X)MK=-1
203 DF=1.
C DF=DUTY FACTOR
DO 2155 L=2,NPA
ISUB=0
C WHY DOES ISUB APPEAR AT 14700/5?
IDF=0
C IDF IS DUTY FACTOR FLAG
IJ=IPT(J,L)
12031 IF(IJ)IJ=JPT(-IJ)
IF(IJ)GO TO 12031
C FOLLOWS UP ON POINTERS TO POINTERS!
PM=1.
IF(IJ.GT.1)GO TO 2157
P(L)=0
GO TO 21551
2157 LN=IJ+2
NM=ABS(V(IJ-1))+LN-4
NL=V(IJ)
IF(NL.GT.-100)GO TO 272
IF(NL.GT.-200)GO TO 372
ISUB=-1
NL=NL+200
C FOR SUBROUTINE FLAG
372 IF(NL.GT.-100)GO TO 272
IDF=-1
NL=NL+100
C DEC.6,72 FINDS DUTY FACTOR PARAM
272 VIJ2=V(IJ+1)
KIJ2=VIJ2
KN=NL/(-11)
IF(KN.EQ.0)GO TO 1100
GO TO (61,62,62,62,65,65,67,68),KN
1100 IF(KIJ2.EQ.1)GO TO 1200
ML=3
1900 KA=1
VX1=0
DO 1156 K=LN,NM,ML
VX(KA+1)=V(K)+VX(KA)
1156 KA=KA+1
X=RAND(0.0,1.)
DO 1157 K=2,11
IF(X.GT.VX(K))GO TO 1157
KL=K-1
IF(KN.EQ.7)GO TO 6157
GO TO 1400
1157 CONTINUE
1400 LN=IJ+3*KL
1462 RA=V(LN)
IF(RA.EQ.-10000.)GO TO 5174
CIRC IF(RA.EQ.10000.)GO TO 5174
C FOR "FINE" IN RLIST
RB=V(LN+1)
PAR=RAND(RA,RB)
1300 IF(NL.NE.-1)PM=2.
C IF 2 THEN PRINTS A5
GO TO 1155
1200 PAR=V(IJ+2)
GO TO 1300
C NEXT IS FOR SUBROUTINE AND QUAD CALLS
61 IF(NL.LT.-12)GO TO 6100
601 X=P2
C '.5' MAKES ALL SUBR PARAMS PRINTOUT.
CALL SUBR
CC 7/74 NOW SET DUR(J) =0 IN SUBR IF(DF)GO TO 5174
C* OUT--COLGATE DF=-1 IN 'SUBR' WILL CAUSE 'END' FOR INST.
IF(L.EQ.2)GO TO 4203
IF(X.EQ.P2)GO TO 21552
PP2=P2
PR=P2
GO TO 21552
C ABOVE IS FOR P2 CHANGES IN SUBROUTINE
C TF,TEMPO,CONDUCT WILL AFFECT P2 ONLY WHEN P2 CALLS THE SUBR.,
C ALL 'TEMPO' CHANGES WILL BE IGNORED!! (THEN DUR. IN SECS. MUST
C BE SET TO 'REAL TIME'.)
6100 IF(NL.EQ.-19)GO TO 6101
C NEXT IS FOR QUAD ROUTINES
CALL QUAD(NL)
GO TO 21552
6101 COFF1(J)=V(LN)
C FOR 'CUTOFF N1, N2' N1=CUTOFF TIME, N2=SHORTEST NOTE.
COFF2(J)=V(LN+1)
GO TO 2155
C FOLLOWING IS FOR STRINGS OF VALUES.
62 KL=NCNT(J,L)+1
IF(KL.GT.KIJ2)KL=1
IF(NL.EQ.-46)GO TO 677
IF(NL.NE.-36)GO TO 162
C THIS PART FOR STRINGS OF RAND SELECTION
677 LN=KL+IJ+1
KL=KL+1
IF(KL.GT.KIJ2)KL=1
NL=NL+45
C FOR NUMBERS ONLY SO FAR(THIS MAKES NL=-1. FOR NOTES, =9)
162 NCNT(J,L)=KL
IF(NL.GT.-22)GO TO 1462
C JUMP RAND SELECTION
PAR=V(IJ+KL+1)
C********** MAY 13,71 RHY REPEAT FEATURE OMITTED.
C************************
IF(KN.NE.3)GO TO 1155
C*******JULY 16,71 IF(PAR.EQ.101.)GO TO 5174
IF(PAR.EQ.-10000.)GO TO 5174
CIRC IF(PAR.EQ.10000.)GO TO 5174
PM=2.
IF(PAR.GT.100.)GO TO 777
IF(PAR.GE.1.)GO TO 877
IF(NL.NE.-33)GO TO 777
C NEXT FOR CHORD FEATURE
PAR=-PAR
CCHD=ABS(V(IJ+KL+2))
KL=KL+1
IF(KL.GT.KIJ2)KL=1
NCNT(J,L)=KL
JCHD=IJ
LLCHD=L
GO TO 877
777 PM=3.
877 IF(PAR.EQ.85.)MK=-1
GO TO 5155
65 W=-9900.-V(IJ-3)
C W=BG TIME OF MOVE.
X=ABS(V(IJ-1))
IF(NL.EQ.-56)GO TO 977
IF(NL.NE.-58)GO TO 771
977 PM=2.
771 Z=(BT-W)/VIJ2
C Z= % OF WAY THROUGH.
IF(Z.GT.1.)Z=1.
Y=V(LN)
W=V(IJ+3)
IF(X.EQ.7.)W=V(IJ+4)
IF(NL.LT.-58)GO TO 16002
PAR=(W-Y)*Z+Y
IF(X.EQ.7.)GO TO 1600
GO TO 1155
C FOR "MOVX"
C THE .01 IS NEEDED FOR MOVE TO OR FROM 0.
16002 PAR=RMOVX(W,Y,Z)
C SEE FUNCTION RMOVX 6/74 -- CAN'T HAVE -20→+20, ETC., -20→-40 OK.
C THIS NEEDS WORK!
IF(X.NE.7.)GO TO 1155
W=V(IJ+5)
Y=V(IJ+3)
X=RMOVX(W,Y,Z)
GO TO 16003
C NEXT IS FOR MOVING RAND RANGES.
C1600 PAR=(V(IJ+4)-Y)*Z+Y
1600 W=V(IJ+3)
C*********** BACK TO 65 IS NEW. FEB. 15,71
X=(V(IJ+5)-W)*Z+W
16003 PAR=RAND(PAR,X)
GO TO 1155
67 LN=IJ+3
NM=LN+KIJ2-1
ML=1
GO TO 1900
4155 K=-(PAR+9999.0)*100.+.1
CIRC4155 K=(PAR-9999.0)*100.+.1
P(L)=P(K)
IF(L.NE.2)GO TO 772
IF(K.EQ.2)P2=PX2
C PX2=LAST UNPROCESSED VALUE OF P2 (+ OR -) 7/74
772 PM=PL(K)
GO TO 21551
C -9999.nn REPEATS ANOTHER PARAM.(-9999.21 REPEATS P21)
C 7/74 **** NOTE PROBLEMS OF P2 WITH SUBR, TEMPO, TF AND RAND. TF.
C ALSO DF. THE REAL TIME VALUE PRINTED MAY HAVE GONE THROUGH MANY
C CHANGES. HENCE WHEN TRANSFERING THE VALUE TO OTHER PARAMS OR
C INSTS GREAT CARE MUST BE TAKEN TO BE SURE THE RESULTS ARE CORRECT.
6157 LN=V(LN-1)
DO 1068 K=1,KL
1068 IF(K.LT.KL)LN=LN+V(LN)+1
2068 PM=LN+1
PAR=LN+V(LN)
GO TO 5155
68 KL=NCNT(J,L)
IF(NL.NE.-1000)GO TO 680
C NEXT FOR CHORDS AND INST NAME CHANGES. LCDH SAVES FOR CHORD FEATURE
IF(J.NE.IFIX(V(IJ-2))/10000)GO TO 2155
C ABOVE CHECKS FOR AGREEMENT OF INST NUM. AND POINTER
C 'DUPL' AND 'ALL' IGNORE 'NAMES'
LCHD=L
IF(CCHD.GE.0)GO TO 2155
CCHD=0
KL=NCNT(J,LLCHD)+1
X=V(JCHD+KL)
IF(X.GE.0)GO TO 9203
NCNT(J,LLCHD)=KL
CCHD=ABS(V(JCHD+KL+1))
GO TO 9203
680 IF(KL.EQ.0)GO TO 774
IF(KL.NE.10000)GO TO 773
774 KL=KIJ2
773 PM=KL+1
PAR=PM+V(KL)-1
KL=PAR+1
IF(V(KL).EQ.-10000.)DUR(J)=BT
CIRC IF(V(KL).EQ.10000.)DUR(J)=BT
C 'END' OR 'FINE' IN 'LIT' LIST.
IF(V(KL).EQ.999.)KL=IJ+2
NCNT(J,L)=KL
GO TO 5155
1155 IF(PAR.EQ.-10000.)GO TO 5174
CIRC1155 IF(PAR.EQ.10000.)GO TO 5174
C TYPE 'END' OR 'FINE' AS LAST IN ANY STRING TO SET DURATION.
IF(PAR.GE.-9999.)GO TO 5155
IF(PAR.LT.-9999.4)GO TO 5155
CIRC IF(PAR.LE.9999.)GO TO 5155
CIRC IF(PAR.GE.9999.4)GO TO 5155
IF(PM.EQ.1.)GO TO 4155
5155 P(L)=PAR
21551 PL(L)=PM
IF(ISUB)GO TO 601
IF(L.EQ.2)GO TO 4203
21552 IF(IDF.GE.0)GO TO 2155
DF=PAR
C DUTY FAC. IS ALWAYS % OF P2 - WHETHER CONSIDERING BASIC OR REAL TIME.
IDF=0
2155 CONTINUE
9203 IF(KB.EQ.0)GO TO 1170
NL=KB
DO 2203 K=1,KB
X=OTH(NL,1)
IF(X.LT.100000.)GO TO 2203
L=X/100000.
Y=(X-L*100000.)/100.
IX=Y
JC=NL
IF(J.NE.L)GO TO 2203
IF(IX.EQ.ICT)GO TO 5203
2203 NL=NL-1
GO TO 1170
5203 JD=Y*100-IX*100+.5
IF(JD.GT.0)GO TO 3203
M=0
P1(J)=PP1+PP2
GO TO 7021
4203 X=COFF1(J)
IF(X.LE.BT)GO TO 6102
C FOR 'CUTOFF N1, N2' N1=CUTOFF TIME, N2=SHORTEST NOTE.
C JUMP IF 'TEMPO' CHANGE
IF(BT+P2.GT.X-COFF2(J))P2=X-BT
6102 PR=P2
PX2=P2
C TO SAVE THE UNPROCESSED P2 FOR 'P2 P2;' IN INPUT. 7/74
IF(T5.EQ.0)GO TO 7203
IF(IT3.LE.1)GO TO 6203
IF(BT.LT.TBG+TDUR)GO TO 6203
3155 IT3=IT3+3
TBG=TBG+TDUR
TDUR=V(IT3)
IF(BT.GE.TBG+TDUR)GO TO 3155
T1=V(IT3+1)
T2=V(IT3+2)
CALL SQYY(AC,T1,T2,TDUR)
6203 RA=PR
IF(BT.EQ.TBG)XT(J)=T1
K=IT3
RC=0
C75 RD=1
KA=1
C75 RB=0
Z=TDUR+TBG-BT
X=T1
Y=T2
YY=AC
CHN=TBG
ZZ=TDUR
CALL ACCEL
8203 P2=RA*RD
7203 P2=P2*T4
X=ABS(P2*TF)
C P2 IS KEPT WITHOUT TF*
K=X+.5
Y=ROFF(J)
Y=Y+K-X
IF(ABS(Y).LT.1.)GO TO 7155
CCC IF(X)K=X-.5
CCC72031 ROFF(J)=ROFF(J)+K-X
CCC IF(ABS(ROFF(J)).LT.1.)GO TO 7155
CCC Y=1.
CCC IF(ROFF(J))Y=-Y
CCC K=K-Y
CCC ROFF(J)=ROFF(J)-Y
X=1
IF(Y)X=-X
K=K-X
Y=Y-X
C ROUND-OFF GAP WILL NOT EXCEED .001****.01 WITH NEW DAC!X?#@
C*********** FEB 17,71
7155 IF(P2)K=-K
PP2=K/RNDOFF
CCC7155 PP2=K/100.
ROFF(J)=Y
CROFF7155 PP2=K/1000.
C AVOIDS ROUND-OFF PROBLEMS **** TO 1/100 (1/76)
C AFTER ALL THIS P2 IN SUBR MAY NOT EQUAL PP2(REAL TIME) DF COMES LATER!
IF(IPT(J,31).EQ.0)GO TO 6155
IF(ICT)GO TO 1170
X=V(IPT(J,31)+2)/2.
IF(PP2.GE.0)GO TO 615
MK=-1
PP2=-PP2
615 Y=IFIX(RAND(-X,X)*RNDOFF+.5)/RNDOFF
C ROUNDS TO 1/100 OR 1/1000 -- RNDOFF
CX IF(Y.GE.PP2)Y=PP2/2.
CX PP2=PP2-RDEV(J)+Y
CX RDEV(J)=Y
W=RDEV(J)
IF(ABS(W+Y).GT.X)Y=-Y
C TOTAL RAND DEV.(RDEV) WON'T EXCEED P31
RDEV(J)=W+Y
PP2=PP2+Y
C SET P31 TO .0001 TO BRING VOICE BACK TO EXACT TIME(0 WON'T DO IT)
CXX W=PP2*100.
CXX K=W+.5
CXX ROFF(J)=ROFF(J)+K-W
CROFF K=PP2*1000.+.5
C****** CHECK THIS OUT 1/10/72 :::::::
CXX61551 PP2=K/100.
C NEVER MORE THAN .1( DEVIATION WITH RAN TF. (RTF=.05)
6155 IF(ICT)GO TO 9203
GO TO 2155
3203 P(JD)=OTH(JC,2)
X=OTH(JC,3)
IF(X.NE.1.)X=3.
C 'EDITS' PRINT,NUM. OR 5 CHARS.
PL(JD)=X
C NEXT ADDED NOV.72 CHECK FOR SIDE AFFECTS !!!!! **********
IF(JD.EQ.2)PP2=P2
C 'TF' AND 'TEMPO' WILL NOT AFFECT PP2 'EDITS'.
1170 IF(MK)GO TO 2022
IF(PP2)GO TO 2022
ZPAR=PP1
P1(J)=PP1+PP2
C ZPAR IS USED HERE WHEN OP1(OMIT) IS .GT.0. OMIT IS IN REAL TIME.
LK=INST(J)
2021 IF(PP1.LT.OP1)GO TO 2612
IF(INVIS(J).LT.0)GO TO 2170
C ALL PARAMS WILL PRINT,1ST TIME WHEN USING 'OMIT'.
IF(INONLY.GT.0)GO TO 1204
6021 IF(P(NPA).NE.COPY(NPA))GO TO 5021
IF(PL(NPA).GT.1)GO TO 5021
C 'LIT' DATA WILL ALWAYS PRINT.
NPA=NPA-1
IF(NPA.GT.2)GO TO 6021
5021 DO 1304 K=3,NPA
1304 COPY(K)=P(K)
1204 IF(PL4.NE.1.)GO TO 2170
P4=P4*AMPFAC
L=0
INP(J)=P4
DO 1021 K=1,NINS
1021 IF(P1(K).GT.PP1)L=L+INP(K)
IF(L-IAMP-1)GO TO 2170
IAMP=L
AMPTIM=PP1
2170 IF(MX.EQ.3)GO TO 2612
PP1=PP1-OP1
C PUTS SPACES BETWEEN NOTES .GT. .05( APART
IF(MZ.NE.-1)GO TO 5170
IF(A.GE.PP1)GO TO 5170
IF(INONLY)WRITE(JOUT,902)
A=PP1+.05
5170 ML=10
IF(NPA.LT.10)ML=NPA
MLX=3
NL=2
IEND=0
K=INVIS(J)
IF(K.EQ.0)GO TO 3170
IF(K.EQ.-1)GO TO 9170
IEND=-1
C THIS DELETES END PRINTOUT ( ;PRINT P1 ETC.)
IF(K.EQ.-2)GO TO 3170
C -1=INVIS FRONT, -2=INVIS END -3=BOTH
9170 LK=0
C NEEDED TO INIT INVISIBLE MODE PRINT-OUT (NO INST NAME, P1, P2)
C NEXT CREATES FORMAT DATA IN IFM ARRAY.
31701 KL=3
GO TO 4170
3170 IF(J.EQ.INONLY)GO TO 775
IF(.NOT.INONLY)GO TO 2612
775 VX(1)=PP1
IF(DF.GT.0)GO TO 6170
VX2=PP2+DF
IF(VX2.LE.0)VX2=PP2/2
C NO NEG. TIME VALUES ALLOWED.
C NEG. DF= FIXED REST AREA BEFORE NEXT ATTACK.
GO TO 7170
6170 IF(DF.LT.100)GO TO 8170
C DF+100=FIXED NOTE DUR. NOT.GT.PP2 7/74 COLGATE -AND BELOW
C DF+1000=FIXED TIME OF OVERLAP 3/77 (CHNG THIS TO 300 SOMEDAY!)
IF(DF.GT.1000)GO TO 8171
VX2=DF-100.
IF(VX2.GT.PP2)VX2=PP2
C DF+200= FIXED DURATION WITHOUT REGARD TO OVERLAPS
IF(DF.GT.200)VX2=DF-200.
GO TO 7170
C*** NEXT FOR DF>1000 ****!!!! SWITCH THIS FEATURE WITH ORD. DF SOMEDAY!!!!
8171 VX2=PP2+DF-1000.
GO TO 7170
8170 VX2=PP2*DF
7170 IFM3='F9.2,'
IFM4=IFM3
KL=5
IF(NPA.LT.3)GO TO 2121
4171 FORMAT(' ******** WARNING: P2 = 0 *********'/)
4170 NL=2
IF(P2.EQ.0)TYPE 4171
DO 1121 K=MLX,ML
X=P(K)
L=PL(K)
IF(L-2)321,521,621
C L=1 NUMBS, =2 NOTES,FUNCS, =3 LITS.
321 IF(X.GE.0)GO TO 4211
IFM(KL)=IFCOM
NL=NL+1
KL=KL+1
4211 IFM(KL)='F7.2,'
IF(P(K).GT.999.99)IFM(KL)='F9.1,'
C CREATES 'F9.1' FOR BIGGER NUMS. (NO NEGS <-999.99)
421 VX(KL-NL)=X
GO TO 1121
521 IFM(KL)=IFM2
C CREATES '1XA5'
LN=X
VX(KL-NL)=SCAL(LN)
GO TO 42
621 IF(L.GT.3)GO TO 721
VX(KL-NL)=X
C ABOVE LETS A5 WD BE USED IN SUBR BY SETTING PL(N)=3.
42 IFM(KL)=IFM2
GO TO 1121
721 LN=X
IFM(KL)=I1X
NL=NL+1
DO 821 M=1,LN-L+1
KL=KL+1
IOUT(KL-NL)=IV(L-1+M)
821 IFM(KL)=IA1
1121 KL=KL+1
C NO MORE THAN 80 ITEMS IN FORMAT.
2121 IF(KL.LE.80)GO TO 21211
21212 FORMAT(' ERROR! TOO MANY LIT. ITEMS')
TYPE 21212
21211 DO 921 M=KL+1,80
921 IFM(M)=IBLA
IFM(KL)=')'
L=KL-NL-1
IF(MX)WRITE(1,IFM)LK,(VX(K),K=1,L)
IF(.NOT.MZ)GO TO 30210
IF(ML.GE.NPA)IFM(KL)='$)'
WRITE(JOUT,IFM),LK,(VX(K),K=1,L)
30210 IF(ML.GE.NPA)GO TO 3021
MLX=ML+1
ML=ML+10
IF(ML.GT.NPA)ML=NPA
LK=IBLA
GO TO 31701
3021 IF(IEND)GO TO 30211
C IEND=-1 FOR INVIS. ENDING. (ALLOWS EXTENTION OF P LIST.)
IF(MX)WRITE(1,3616)INST(J),ICT
30211 IF(MZ)WRITE(JOUT,8902),J,INST(J),ICT,BT
2612 PP1=ZPAR
GO TO 21
8902 FORMAT('+;<'I2,1XA5,I4,' >',F7.2)
3616 FORMAT(';PRINT P1;< ',A5,I4)
C PRINTS RESTS
2022 PP2=ABS(PP2)
C IN THIS VERSION TYPE 'R' FOR RESTS IN ANY PARAM BUT P2.
C FOR RESTS IN SEQS. TYPE -DUR.
C WHEN RANDOM RESTS ARE CHOSEN, SEQS. MISS NOTES.
C RAN RESTS ARE TOUCHED BY SUBROUTINES ONLY BY SETTING IREST!!
INP(J)=0
P1(J)=PP1+PP2
C STORES NEXT P1 TIME FOR THIS INST.
IF((MZ.NE.-1).OR.(PP1.LT.OP1))GO TO 21
X=PP1-OP1
IF(A.GE.X)GO TO 121
WRITE(JOUT,902)
A=X+.05
C NEXT PRINTS A REST INDICATION
121 IF(INONLY.OR.J.EQ.INONLY)WRITE(JOUT,1110),INST(J),X,PP2,
1 J,INST(J),ICT,BT
21 IF(CCHD.EQ.0)GO TO 122
C NEXT FOR CHORDS
P3=CCHD
L=LCHD
NL=-1000
CCHD=-CCHD
GO TO 68
122 PR=ABS(PR)
BG(J)=BT+PR
IF(ICT.EQ.DUR(J)-10000.)GO TO 5174
IF(BG(J).LT.DUR(J))GO TO 500
5174 BG(J)=19999.
DO 3174 K=1,NINS
C INSERTS CAN'T FOLLOW LAST REGULAR NOTE.
C (ADD REST IF INSERT AT END IS NEEDED.)
3174 IF(BG(K).LT.19999.)GO TO 500
GO TO 175
C CHOOSES INST WITH NEXT BEGIN TIME.
500 J=1
BW=BT
NL=NINS+KB
DO 22 K=2,NL
22 IF(BG(J).GT.BG(K))J=K
IF(J.GT.NINS.OR.NINS.EQ.1)GO TO 3022
J=1
DO 5022 K=2,NINS
X=P1(J)
Y=P1(K)+.0001
C LOWEST NUMBERED INST WILL COME 1ST IF BG TIMES ARE VERY CLOSE
IF(BG(J).EQ.19999.)X=19999.
IF(BG(K).EQ.19999.)Y=19999.
5022 IF(X.GT.Y)J=K
C ABOVE IS FOR ROUND-OFF PROBLEMS WITH 'TEMPO' AND 'CONDUCT'.
3022 BT=BG(J)
IF((BT.EQ.19999.).OR.(P1(J).GE.DURX))GO TO 175
IF(CNT(J).GT.0)GO TO 1022
IF(CNT(J).EQ.0)P1(J)=0
IF(CNT(J).EQ.-1)CNT(J)=0
C N.B. 'TF' CONTROLS BG TIME WHEN BG .GT. 0
1022 IF((BT.LT.T6).OR.(IT3.GT.1))GO TO 1108
T4=T2
T5=0
T6=10000.
GO TO 1108
1175 FORMAT('+',A5,'=',F7.2,2X,$)
1109 FORMAT(' FINISH; < ',A5,'.DAT')
1110 FORMAT(' <',A5,2F8.2,2X,'******* REST <'I2,1XA5,I4,F11.2)
1603 FORMAT(' AMPL. FACTOR=',F4.2,', P4 MAX.AMP.=',I6,', AT TIME'
1,F8.3)
175 IF(MZ)WRITE(JOUT,1109),ISLAC
IF(MX.GE.0)GO TO 4175
WRITE(1,1109),ISLAC
END FILE 1
TYPE 60003
60003 FORMAT(/' ***** DATA HAS BEEN WRITTEN ON DISK *****'/)
603 FORMAT(' TOTAL DURS: ',$)
CC FOR COLGATE ONLY***4175 CALL ENDSUB
C CLEARS CNTL O --- IF YOU HAVE HIT IT.
4175 WRITE(JOUT,1603),AMPFAC,IAMP,AMPTIM
WRITE(JOUT,603)
5175 DO 2175 K=1,NINS
X=P1(K)-OP1
IF(MZ)GO TO 6175
TYPE 1175,INST(K),X
GO TO 2175
6175 WRITE(JOUT,1175),INST(K),X
2175 CONTINUE
3175 TYPE 1023,ISLAC,IXIN
END